Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d18/facilis2.arc/TEST.PAS

Pascal/Delphi Source File | 1991-04-28 | 22KB | 1,005 lines

program test(input,output);

{    Pascal Compiler Test Program
     Version 1.31

     Written by John R. Naleszkiewicz
     Date: October 19, 1984
   Update: January 15, 1985
             August 5, 1985
            August 16, 1985      }

const
     start = 10;
     finish = 50;
     version = 1.31;

type
     rec = record
             f1 : integer;
             f2 : real;
             f3 : boolean;
             f4 : array[1 .. 3] of char;
           end;

var
   a,i,j : integer;
   e,x,y : real;
     b,f : boolean;
     c,h : char;
     ain : array[0 .. 10] of integer;
     arl : array[start .. finish] of real;
     abl : array[-5 .. 5] of boolean;
     ach : array[1 .. 25] of char;
 in1,in2 : array[-2 .. 8] of integer;
 rl1,rl2 : array[-2 .. 8] of real;
 bl1,bl2 : array[-2 .. 8] of boolean;
 ch1,ch2 : array[-2 .. 8] of char;
  errors : integer;

     alist,blist : rec;


procedure ptest1;
var
  i : integer;
  x : real;
  begin
    writeln('called');
    i := -10;
    x := -15.0
  end; { ptest1 }

procedure ptest2(i : integer; x : real; var j : integer; var y : real);
  begin
    writeln('called');
    if i<>10 then
      begin
        writeln('*** Call by value integer passed incorrectly (P)');
        errors := errors+1;
      end;
    if x<>10.0 then
      begin
        writeln('*** Call by value real passed incorrectly (P)');
        errors := errors+1;
      end;
    if j<>25 then
      begin
        writeln('*** Call by reference integer passed incorrectly (P)');
        errors := errors+1;
      end;
    if y<>25.0 then
      begin
        writeln('*** Call by reference real passed incorrectly (P)');
        errors := errors+1;
      end;
    j := j - 1;
    y := y - 1.0
  end; { ptest2 }

procedure ptest3(i : integer);
  begin
    write(i:1);
    if i>0 then
      ptest3(i-1)
  end; { ptest3 }

function ftest1(k : integer; z : real): integer;
  begin
    writeln('called');
    if k<>0 then
      begin
        writeln('*** Call by value integer passed incorrectly (F)');
        errors := errors+1;
      end;
    if z<>75.0 then
      begin
        writeln('*** Call by value real passed incorrectly (F)');
        errors := errors+1;
      end;
    ftest1 := 100
  end; { ftest1 }

function ftest2(m : integer): integer;
  begin
    if m>0 then
      ftest2 := ftest2(m-1) + 2
    else
      ftest2 := 0;
    write(m:1)
  end; { ftest2 }


begin  { main program }
  writeln;
  writeln('  Pascal Compiler Test Program -- Version ',version:4:2);
  writeln;

  errors := 0;
  writeln('If statement and logical tests (P=pass, F=fail)');
  write('  Simple logical test (PP):');
  if true then
    write('P')
  else
    write('F');
  if false then
    writeln('F')
  else
    writeln('P');
  write('  Logical NOT test (PP):');
  if not true then
    write('F')
  else
    write('P');
  if not false then
    writeln('P')
  else
    writeln('F');
  write('  Logical AND test (PPP):');
  if true and true then
    write('P')
  else
    write('F');
  if true and false then
    write('F')
  else
    write('P');
  if false and false then
    writeln('F')
  else
    writeln('P');
  write('  Logical OR test (PPP):');
  if true or true then
    write('P')
  else
    write('F');
  if true or false then
    write('P')
  else
    write('F');
  if false or false then
    writeln('F')
  else
    writeln('P');
  write('  Logical comparison tests = <> < > <= >= (PPPPPPPP):');
  if 10 = 10 then
    write('P')
  else
    write('F');
  if 10 <> 1 then
    write('P')
  else
    write('F');
  if 1 < 10 then
    write('P')
  else
    write('F');
  if 10 > 1 then
    write('P')
  else
    write('F');
  if 10 <= 10 then
    write('P')
  else
    write('F');
  if 1 <= 10 then
    write('P')
  else
    write('F');
  if 10 >= 10 then
    write('P')
  else
    write('F');
  if 10 >= 1 then
    writeln('P')
  else
    writeln('F');

  writeln;
  write('   Enter "C" <return> to continue');
  read(c);
  writeln;
  writeln;

  writeln('  Variable assignment tests');
  writeln('    Simple variable assignment tests');
  i := 10;
  writeln('    Integer stored:    10, contents: ',i:3);
  j := i;
  if j<>10 then
    begin
      write('*** Integer assignment test failed, ');
      writeln(j,' instead of 10');
      errors := errors+1;
    end;

  j := -i;
  writeln('    Integer stored:   -10, contents: ',j:3);
  if j<>-10 then
    begin
      write('*** Integer negation test failed, ');
      writeln(j,' instead of -10');
      errors := errors+1;
    end;

  x := 10.0;
  writeln('    Real stored:  1.0000E+01, contents:',x);
  y := x;
  if y<>10.0 then
    begin
      write('*** Floating point assignment failed, ');
      writeln(y,' instead of 1.0000E+01');
      errors := errors+1;
    end;

  y := -x;
  writeln('    Real stored: -1.0000E+01, contents:',y);
  if y<>-10.0 then
    begin
      write('*** Floating point negation failed, ');
      writeln(y,' instead of -1.0000E+01');
      errors := errors+1;
    end;

  b := true;
  f := b;
  if not f then
    begin
      write('*** Boolean assignment (true) failed, ');
      writeln('false instead of true');
      errors := errors+1;
    end;

  b := false;
  f := b;
  if f then
    begin
      write('*** Boolean assignment (false) failed, ');
      writeln('true instead of false');
      errors := errors+1;
    end;

  c := 'x';
  h := c;
  if h<>'x' then
    begin
      write('*** Character assignment failed, ');
      writeln('result of "',h,'" instead of "x"');
      errors := errors+1;
    end;


  writeln('    Array assignment tests');
  ain[0] := 25;
  ain[5] := ain[0];
  if ain[5]<>25 then
    begin
      write('*** Integer array assignment failed, ');
      writeln(ain[5],' instead of 25');
      errors := errors+1;
    end;

  arl[25] := 1000.0;
  arl[45] := arl[25];
  if arl[45]<>1000.0 then
    begin
      write('*** Floating point array assignment failed, ');
      writeln(arl[45],' instead of 1.0000E+03');
      errors := errors+1;
    end;

  abl[-3] := true;
  abl[3]  := abl[-3];
  if not abl[3] then
    begin
      write('*** Boolean array assignment (true) failed, ');
      writeln('false instead of true');
      errors := errors+1;
    end;

  abl[0] := false;
  abl[5] := abl[0];
  if abl[5] then
    begin
      write('*** Boolean array assignment (false) failed, ');
      writeln('true instead of false');
      errors := errors+1;
    end;

  ach[10] := 'a';
  ach[23] := ach[10];
  if ach[23]<>'a' then
    begin
      write('*** Character array assignment failed, ');
      writeln('result of "',ach[23],'" instead of "a"');
      errors := errors+1;
    end;


  writeln('    Block Array assignment tests');
  for i:=-2 to 8 do
    begin
      in1[i] := i*3;
      rl1[i] := i*2.0;
      if odd(i) then
        bl1[i] := true
      else
        bl1[i] := false;
      ch1[i] := chr(i+67);
    end;
  in2 := in1;
  rl2 := rl1;
  bl2 := bl1;
  ch2 := ch1;

  for i:=-2 to 8 do
    begin
      if in1[i]<>i*3 then
       begin
         write('*** Block Integer array assignment failed, ');
         writeln('at position ',i);
         errors := errors+1;
       end;

      if rl1[i]<>i*2.0 then
        begin
          write('*** Block Real array assignment failed, ');
          writeln('at position ',i);
          errors := errors+1;
        end;

      if odd(i) then
        if bl1[i]<>true then
          begin
            write('*** Block Boolean array assignment failed, ');
            writeln('at position ',i);
            errors := errors+1;
          end
        else
      else
        if bl1[i]<>false then
          begin
            write('*** Block Boolean array assignment failed, ');
            writeln('at position ',i);
            errors := errors+1;
          end;
     if ch1[i]<>chr(i+67) then
        begin
          write('*** Block Character array assignment failed, ');
          writeln('at position ',i);
          errors := errors+1;
        end;

    end;


  writeln('    Record field assignment tests');
  alist.f1 := 99;
  alist.f2 := 12.5;
  alist.f3 := true;
  alist.f4[1] := 'a';
  alist.f4[2] := 'b';
  alist.f4[3] := alist.f4[1];
  blist := alist;
  if blist.f1<>99 then
    begin
      write('*** Integer field assignment failed, ');
      writeln(blist.f1,' instead of 99');
      errors := errors+1;
    end;

  if blist.f2<>12.5 then
    begin
      write('*** Real field assignment failed, ');
      writeln(blist.f2,' instead of 1.2500E+01');
      errors := errors+1;
    end;

  if not blist.f3 then
    begin
      write('*** Boolean field assignment failed, ');
      writeln('false instead of true');
      errors := errors+1;
    end;

  if blist.f4[3]<>'a' then
    begin
      write('*** Character array field assignment failed, ');
      writeln('result of "',blist.f4[3],'" instead of "a"');
      errors := errors+1;
    end;


  writeln('  Builtin function tests');
  i := 3;
  if not odd(i) then
    begin
      write('*** Function odd(x) failed, ');
      writeln(i,' was found to be even');
      errors := errors+1;
    end;

  i := 4;
  if odd(i) then
    begin
      write('*** Function odd(x) failed, ');
      writeln(i,' was found to be odd');
      errors := errors+1;
    end;

  x := 1.77;
  i := round(x);
  j := trunc(x);
  if i<>2 then
    begin
      write('*** Function round(x) failed, ');
      writeln(i,' instead of 2');
      errors := errors+1;
    end;
  if j<>1 then
    begin
      write('*** Function trunc(x) failed, ');
      writeln(i,' instead of 1');
      errors := errors+1;
    end;

  i := -25;
  j := abs(i);
  if j <> 25 then
    begin
      write('*** Function abs(integer) failed, ');
      writeln(j,' instead of 25');
      errors := errors+1;
    end;

  i := 99;
  j := abs(i);
  if j <> 99 then
    begin
      write('*** Function abs(integer) failed, ');
      writeln(j,' instead of 99');
      errors := errors+1;
    end;

  x := -12.5;
  y := abs(x);
  if y <> 12.5 then
    begin
      write('*** Function abs(real) failed, ');
      writeln(y,' instead of 1.2500E+01');
      errors := errors+1;
    end;

  x := 112.5;
  y := abs(x);
  if y <> 112.5 then
    begin
      write('*** Function abs(real) failed, ');
      writeln(y,' instead of 1.1250E+02');
      errors := errors+1;
    end;

  i := 7;
  j := sqr(i);
  if j <> 49 then
    begin
      write('*** Function sqr(integer) failed, ');
      writeln(j,' instead of 49');
      errors := errors+1;
    end;

  x := 5.0;
  y := sqr(x);
  if y <> 25.0 then
    begin
      write('*** Function sqr(real) failed, ');
      writeln(y,' instead of 2.5000E+01');
      errors := errors+1;
    end;

  x := 729.0;
  y := sqrt(x);
  if y <> 27.0 then
    begin
      write('*** Function sqrt(x) failed, ');
      writeln(y,' instead of 2.7000E+01');
      errors := errors+1;
    end;

  c := 'x';
  i := ord(c);
  h := chr(i);
  if i<>120 then
    begin
      write('*** Function ord(x) failed, ');
      writeln(i,' instead of 120');
      errors := errors+1;
    end;
  if h<>'x' then
    begin
      write('*** Function chr(x) failed, ');
      writeln('"',h,'" instead of "x"');
      errors := errors+1;
    end;

  i := 10;
  j := succ(i);
  if j<>11 then
    begin
      write('*** Function succ(x) failed, ');
      writeln(j,' instead of 11');
      errors := errors+1;
    end;

  i := 99;
  j := pred(i);
  if j<>98 then
    begin
      write('*** Function pred(x) failed, ');
      writeln(j,' instead of 98');
      errors := errors+1;
    end;



  writeln('  Arithmetic tests');
  writeln('    Integer arithmetic tests');
  i := 5 + 5;
  j := i + 10;
  j := j + i;
  if j<>30 then
    begin
      write('*** Addition failed, ');
      writeln(j,' instead of 30');
      errors := errors+1;
    end;

  i := 20 - 8;
  j := i - 10;
  j := i - j;
  if j<>10 then
    begin
      write('*** Subtraction failed, ');
      writeln(j,' instead of 10');
      errors := errors+1;
    end;

  i := 2 * 3;
  j := i * 4;
  j := j * i;
  if j<>144 then
    begin
      write('*** Multiplication failed, ');
      writeln(j,' instead of 144');
      errors := errors+1;
    end;

  i := 100 div 5;
  j := i div 10;
  j := i div j;
  if j<>10 then
    begin
      write('*** Division failed, ');
      writeln(j,' instead of 10');
      errors := errors+1;
    end;

  i := 102 mod 15;
  j := i mod 7;
  j := i mod j;
  if j<>2 then
    begin
      write('*** MOD failed, ');
      writeln(j,' instead of 2');
      errors := errors+1;
    end;

  i := 10;
  j := i + 7;
  j := (j - i) * (i - 2 * j);
  if j<>-168 then
    begin
      write('*** Hierarchy failed, ');
      writeln(j,' instead of -168');
      errors := errors+1;
    end;

  writeln('    Floating point arithmetic tests');
  x := 1.0 / 3.0;
  x := x * 3.0;
  y := 1.0 - x;
  if y=0.0 then
    i := 99
  else
    a := round(-ln(y) / ln(10.0));
  writeln('      Internal accuracy (digits): ',a:2);
  x := 2.0 + 3.0;
  y := x + 10.2;
  y := y + x;
  if y<>20.2 then
    begin
      write('*** Addition failed, ');
      writeln(y,' instead of 2.0200E+01');
      errors := errors+1;
    end;

  x := 20.0 - 8.7;
  y := x - 10.3;
  y := x - y;
  if y<>10.3 then
    begin
      write('*** Subtraction failed, ');
      writeln(y,' instead of 1.0300E+01');
      errors := errors+1;
    end;

  x := 2.0 * 3.0;
  y := x * 4.0;
  y := y * x;
  if y<>144.0 then
    begin
      write('*** Multiplication failed, ');
      writeln(y,' instead of 1.4400E+02');
      errors := errors+1;
    end;

  x := 100.0 / 5.0;
  y := x / 10.0;
  y := x / y;
  if y<>10.0 then
    begin
      write('*** Division failed, ');
      writeln(y,' instead of 1.0000E+01');
      errors := errors+1;
    end;

  x := 10.0;
  y := x + 7.0;
  y := (y - x) * (x - 2.0 * y);
  if y<>-168.0 then
    begin
      write('*** Hierarchy failed, ');
      writeln(y,' instead of -1.6800E+02');
      errors := errors+1;
    end;

  x := 5;
  i := 10;
  y := i + 15 / x;
  j := trunc( 7 + x / 2 - 0.8 );
  if (y<>13.0) OR (j<>8) then
    begin
      write('*** Mixed mode arithmetic failed, ');
      writeln(y,', ',j,' instead of 13.0, 8');
      errors := errors+1;
    end;

  writeln('    Log/Trig Function tests');
  e := 1.0;
  for i:=1 to (a-1) do
    e := e * 10.0;        { compute the error multiplier }

  x := exp(1.0);
  y := ln(x);
  x := abs(1.0 - y) * e;  { compute the maximum allowable error }
  if x>0.5 then
    begin
      write('*** Function exp(x) or ln(x) failed, ');
      writeln(y,' instead of 1.0000E+00');
      errors := errors+1;
    end;

  y := sqr(sin(1.0)) + sqr(cos(1.0));
  x := abs(1.0 - y) * e;  { compute the maximum allowable error }
  if x>0.5 then
    begin
      write('*** Function sin(x) or cos(x) failed, ');
      writeln(y,' instead of 1.0000E+00');
      errors := errors+1;
    end;

  x := sin(1.0) / cos(1.0);
  y := arctan(x);
  x := abs(1.0 - y) * e;  { compute the maximum allowable error }
  if x>0.5 then
    begin
      write('*** Function arctan(x) failed, ');
      writeln(y,' instead of 1.0000E+00');
      errors := errors+1;
    end;


  writeln;
  write('  Enter "C" <return> to continue');
  read(c);
  writeln;
  writeln;

  writeln('  Control Structure testing');
  writeln('    Nested IF structure tests');
  a := 99;
  i := 10;
  j := 25;
  x := 13.5;
  y := -45.0;
  if i<j then
    if x>y then
      if i>17 then
        a := 3
      else
        a := 0
    else
      a := 2
  else
    a := 1;
  if a<>0 then
    begin
      write('*** Nested IF structure failed, ');
      writeln(a,' instead of 0');
      errors := errors+1;
    end;

  writeln('    FOR structure tests');
  a := 0;
  for i:=0 to 10 do
    begin
      ain[i] := i+1;
      a := a+1;
    end;
  if a<>11 then
    begin
      write('*** FOR (to) integer index count failed, ');
      writeln(a,' instead of 11');
      errors := errors+1;
    end;
  a := 0;
  for i:=10 downto 0 do
    begin
      if ain[i]<>(i+1) then
        begin
          write('*** Array assignment failed at position ',i,', ');
          writeln(ain[i],' instead of ',i+1);
          errors := errors+1;
        end;
      a := a+1;
    end;
  if a<>11 then
    begin
      write('*** FOR (downto) integer index count failed, ');
      writeln(a,' instead of 11');
      errors := errors+1;
    end;

  a := 0;
  for c:='c' to 'p' do
    a := a+1;
  if a<>14 then
    begin
      write('*** FOR (to) character index count failed, ');
      writeln(a,' instead of 14');
      errors := errors+1;
    end;
  a := 0;
  for c:='r' downto 'a' do
    a := a+1;
  if a<>18 then
    begin
      write('*** FOR (downto) character index count failed, ');
      writeln(a,' instead of 18');
      errors := errors+1;
    end;

  writeln('    Nested FOR structure tests');
  a := 0;
  for i:=1 to 25 do
    for j:= -5 to 4 do
      a := a + 1;
  if a<>250 then
    begin
      write('*** Nexted FOR index count failed, ');
      writeln(a,' instead of 250');
      errors := errors+1;
    end;

  writeln('    CASE structure tests');
  i := 5;
  j := 99;
  case i of
    1 : j := 1;
    2 : j := 2;
    3 : j := 3;
    4 : j := 4;
    5 : j := 5;
    6 : j := 6;
  end;
  if j<>5 then
    begin
      write('*** CASE statement (integer) failed, ');
      writeln(j,' instead of 5');
      errors := errors+1;
    end;

  c := 'g';
  case c of
    'a' : j := 1;
    'c' : j := 2;
    'g' : j := 3;
    'z' : j := 4;
  end;
  if j<>3 then
    begin
      write('*** CASE statement (character) failed, ');
      writeln(j,' instead of 3');
      errors := errors+1;
    end;

  writeln('    Nested CASE structure tests');
  i := 7;
  j := 5;
  a := 99;
  case i of
    1 : a := 10;
    7 : case j of
          1 : a := 21;
          9 : a := 22;
          5 : a := 23;
        end;
    9 : a := 30;
  end;
  if a<>23 then
    begin
      write('*** Nested CASE statement failed, ');
      writeln(a,' instead of 23');
      errors := errors+1;
    end;

  writeln('    WHILE structure tests');
  i := 100;
  while (i>0) and (i<101) do
    i := i-1;
  if i<>0 then
    begin
      write('*** WHILE statement failed, ');
      writeln(i,' instead of 0');
      errors := errors+1;
    end;

  writeln('    Nested WHILE structure tests');
  i := 200;
  j := 0;
  a := 0;
  while (i>5) and (i<201) do
    begin
      i := i-1;
      j := j+1;
      while (i mod 5) <> 1 do
        begin
          a := a+1;
          i := i-2;
        end;
    end;
  if (i<>1) or (j<>39) or (a<>80) then
    begin
      write('*** Nested WHILE statement failed, ');
      writeln(i,', ',j,', ',a,' instead of 1, 39, 80');
      errors := errors+1;
    end;

  writeln('    REPEAT structure tests');
  i := 450;
  repeat
   i := i-1;
  until (i<250) or (i>450);
  if i<>249 then
    begin
      write('*** REPEAT statement failed, ');
      writeln(i,' instead of 249');
      errors := errors+1;
    end;

  writeln('    Nested REPEAT structure tests');
  i := 450;
  j := 0;
  a := 0;
  repeat
   i := i-1;
   j := j+1;
   repeat
     i := i-3;
     a := a+1;
   until odd(i);
  until (i<100) or (i>450);
  if (i<>99) or (j<>87) or (a<>88) then
    begin
      write('*** Nested REPEAT statement failed, ');
      writeln(i,', ',j,', ',a,' instead of 99, 87, 88');
      errors := errors+1;
    end;


  writeln;
  write('  Enter "C" <return> to continue');
  read(c);
  writeln;
  writeln;

  writeln('  Procedure and function testing');
  writeln('    Procedure call tests');
  i := 0;
  x := 10.0;
  write('      Procedure 1 ');
  ptest1;
  if i<>0 then
    begin
      writeln('*** Integer local variables damaging globals');
      errors := errors+1;
    end;
  if x<>10.0 then
    begin
      writeln('*** Real local variables damaging globals');
      errors := errors+1;
    end;

  j := 25;
  y := 25.0;
  write('      Procedure 2 ');
  ptest2(10,10.0,j,y);
  if j<>24 then
    begin
      writeln('*** Call by reference integer not returned correctly');
      errors := errors+1;
    end;
  if y<>24.0 then
    begin
      writeln('*** Call by reference real not returned correctly');
      errors := errors+1;
    end;

  writeln('      Recursive procedure test (5..0)');
  write('      ');
  i := 5;
  ptest3(i);
  writeln;
  if i<>5 then
    begin
      writeln('*** Call by value in recursive test failed');
      errors := errors+1;
    end;

  writeln('    Function call tests');
  i := 0;
  x := 75.0;
  write('      Function 1 ');
  i := ftest1(i,x);
  if i<>100 then
    begin
      writeln('*** Function not returning correct value');
      errors := errors+1;
    end;

  writeln('      Recursive function  test (0..5)');
  write('      ');
  i := 5;
  j := ftest2(i);
  writeln;
  if i<>5 then
    begin
      writeln('***   Call by value in recursive function test failed');
      errors := errors+1;
    end;
  if j<>10 then
    begin
      writeln('***   Function not returning correct value during recursion');
      errors := errors+1;
    end;


  writeln;
  writeln('  Testing complete');
  if errors > 0 then
    writeln(errors, ' Error(s) Found')
  else
    writeln('  No Errors Found')

end.